home *** CD-ROM | disk | FTP | other *** search
/ TPUG - Toronto PET Users Group / TPUG Users Group CD / TPUG Users Group CD.iso / AMIGA / AMICUS / AMICUS11.ADF / Modula-2 / SimpleRequester.MOD < prev    next >
Encoding:
Text File  |  1986-08-06  |  6.9 KB  |  222 lines
  1. MODULE SimpleReq;
  2.  
  3. (*
  4.    Example of a custom  requester from Modula-2.
  5.  
  6.    Created: 6/15/86 by Richard Bielak
  7.    
  8.    Modified:
  9.  
  10.    Copyright 1986, by Richard Bielak - (CIS 75716,352)
  11.    This program may be freely distributed, but please leave my
  12.    name in. Thanks.
  13.  
  14. *)
  15. FROM Terminal IMPORT WriteString, WriteLn;
  16. FROM SYSTEM IMPORT ADR, BYTE, ADDRESS;
  17. FROM Intuition IMPORT
  18.      IntuitionName, IntuitionBase, Window, WindowFlags, NewWindow,
  19.      IDCMPFlags, IDCMPFlagsSet, WindowFlagsSet, WindowPtr, IntuitionText,
  20.      Requester, RequesterFlagsSet, Gadget, GadgetFlagsSet, IntuiMessagePtr,
  21.      ActivationFlagsSet, ActivationFlags, Border;
  22. FROM Libraries IMPORT OpenLibrary;
  23. FROM Windows IMPORT OpenWindow, SmartRefresh;
  24. FROM GraphicsLibrary IMPORT Jam2, Jam1, DrawingModeSet;
  25. FROM Requesters   IMPORT InitRequester, Request;
  26.  
  27. (* This import is needed to avoid a name conflict, the procedure *)
  28. (* to close the window in Window is called "CloseWindow", and    *)
  29. (* the IDCMPFlag that says send us a close window message is     *)
  30. (* also called "CloseWindow".                                    *)
  31. IMPORT Windows;
  32.  
  33. FROM Screens IMPORT WBenchScreen;
  34. FROM Ports   IMPORT WaitPort, ReplyMsg, MessagePtr;
  35.  
  36. (* Note use of a different module for GetMsg. TDI's GetMsg *)
  37. (* doesn't work.                                           *)
  38. FROM Fixes IMPORT GetMsg;
  39.  
  40.  
  41. CONST
  42.   IntuitionRev = 29;
  43.   BOOLGADGET = 1H;
  44.   REQGADGET = 1000H;
  45.  
  46. VAR
  47.   NULL : ADDRESS;
  48.   MyWindow : NewWindow;
  49.   MyWindowName : ARRAY [0..20] OF CHAR;
  50.   wp : WindowPtr;
  51.   msgptr : IntuiMessagePtr;
  52.   succ : BOOLEAN;
  53.   class : IDCMPFlagsSet;
  54.   
  55.   (* Stuff for the requester *)
  56.   SimpleReq : Requester;
  57.   SimpleGadget : Gadget;
  58.   GadText,
  59.   SimpleText1,
  60.   SimpleText2 : IntuitionText;
  61.   GadgetBorder,
  62.   SimpleBorder : Border;  
  63.   GadTextStr, ReqText1, ReqText2 : ARRAY [0..30] OF CHAR;
  64.   Pairs : ARRAY [1..10] OF INTEGER;
  65.   GPairs : ARRAY [1..10] OF INTEGER;
  66.       
  67. (* ++++++++++++++++++++++++++++++++++++++++ *)
  68. PROCEDURE InitWindow (VAR w : NewWindow);
  69.   BEGIN
  70.     MyWindowName := "Simple Requester";
  71.     WITH w DO
  72.       LeftEdge := 200; TopEdge := 0; Width := 320; Height := 200;
  73.       DetailPen := BYTE (0);
  74.       BlockPen := BYTE (1);
  75.       Title := ADR (MyWindowName);
  76.       Flags := WindowFlagsSet {Activate, WindowClose, WindowDrag,
  77.                WindowDepth, NoCareRefresh} + SmartRefresh;
  78.       IDCMPFlags := 
  79.          IDCMPFlagsSet{CloseWindow, ReqClear,GadgetDown, GadgetUp};
  80.       Type := CARDINAL(WBenchScreen);
  81.       CheckMark := NULL;
  82.       FirstGadget := NULL;
  83.       Screen := NULL;
  84.       BitMap := NULL;
  85.       MinWidth := 10; MinHeight := 10;
  86.       MaxWidth := 640; MaxHeight := 200;
  87.     END
  88.   END InitWindow;
  89.  
  90. (* ++++++++++++++++++++++++++++++++++++++++ *)
  91. PROCEDURE SetUpGadget ();
  92.   BEGIN
  93.     (* Coordinates for border of the gadget box *)
  94.     GPairs [1] := 0;    GPairs [2] := 0;    
  95.     GPairs [3] := 61;    GPairs [4] := 0;
  96.     GPairs [5] := 61;    GPairs [6] := 11;
  97.     GPairs [7] := 0;    GPairs [8] := 11;
  98.     GPairs [9] := 0;    GPairs [10] := 0;    
  99.  
  100.     WITH GadgetBorder DO
  101.       LeftEdge := -1; TopEdge := -1;
  102.       FrontPen := BYTE (3); BackPen := BYTE (0);
  103.       DrawMode := BYTE (Jam1); Count := BYTE (5);
  104.       XY := ADR (GPairs); NextBorder := NULL;
  105.     END;
  106.  
  107.     (* Text that appears in the gadget *)
  108.     GadTextStr := "Click";
  109.     WITH GadText DO
  110.       FrontPen := BYTE (2); BackPen := BYTE (1);
  111.       DrawMode := BYTE (DrawingModeSet {Jam2});
  112.       LeftEdge := 5; TopEdge := 1;
  113.       ITextFont := NULL; NextText := NULL;
  114.       IText := ADR (GadTextStr);
  115.     END;
  116.  
  117.     (* The gadget structure *)
  118.     WITH SimpleGadget DO
  119.       NextGadget := NULL;
  120.       LeftEdge := 70; TopEdge := 45;  Width := 60; Height := 10;
  121.       Flags := GadgetFlagsSet {};
  122.       Activation := ActivationFlagsSet {EndGadget, RelVerify};
  123.       GadgetType := BOOLGADGET + REQGADGET;
  124.       GadgetRender := ADR (GadgetBorder);
  125.       SelectRender := NULL;
  126.       GadgetText := ADR (GadText);
  127.       MutualExclude := 0;
  128.       SpecialInfo := NULL; GadgetID := 0; UserData := NULL
  129.     END;
  130.   END SetUpGadget;
  131.  
  132. (* ++++++++++++++++++++++++++++++++++++++++ *)
  133. PROCEDURE SetUpRequester ();
  134.   BEGIN
  135.     (* Coordinates for border of the requester *)
  136.     Pairs [1] := 0;    Pairs [2] := 0;    
  137.     Pairs [3] := 197;    Pairs [4] := 0;
  138.     Pairs [5] := 197;    Pairs [6] := 57;
  139.     Pairs [7] := 0;    Pairs [8] := 57;
  140.     Pairs [9] := 0;    Pairs [10] := 0;    
  141.  
  142.     WITH SimpleBorder DO
  143.       LeftEdge := 1; TopEdge := 1;
  144.       FrontPen := BYTE (3); BackPen := BYTE (0);
  145.       DrawMode := BYTE (Jam1); Count := BYTE (5);
  146.       XY := ADR (Pairs); NextBorder := NULL;
  147.     END;
  148.  
  149.     (* Text that appears in the gadget *)
  150.     ReqText1 := "Example of a Requester";
  151.     ReqText2 := "   from Modula-2";
  152.     WITH SimpleText1 DO
  153.       FrontPen := BYTE (2); BackPen := BYTE (1);
  154.       DrawMode := BYTE (DrawingModeSet {Jam2});
  155.       LeftEdge := 5; TopEdge := 10;
  156.       ITextFont := NULL; NextText := ADR (SimpleText2);
  157.       IText := ADR (ReqText1);
  158.     END;
  159.     SimpleText2 := SimpleText1;
  160.     WITH SimpleText2 DO
  161.       LeftEdge := 5; TopEdge := 20;
  162.       NextText := NULL; IText := ADR (ReqText2);
  163.     END;
  164.  
  165.     (* InitRequestor is called to zero out the request   *)
  166.     (* structure. Must be called before putting stuff in *)
  167.     InitRequester (SimpleReq);
  168.  
  169.     WITH SimpleReq DO
  170.       LeftEdge := 20; TopEdge := 30;
  171.       Width := 200; Height := 60;
  172.       ReqGadget := ADR (SimpleGadget);
  173.       ReqText := ADR (SimpleText1);
  174.       ReqBorder := ADR (SimpleBorder);
  175.       BackFill := BYTE (1);
  176.     END;
  177.   END SetUpRequester;
  178.  
  179. BEGIN
  180.   NULL := ADDRESS (0);
  181.   (* Open intuition library *)
  182.   IntuitionBase := OpenLibrary (IntuitionName,IntuitionRev);
  183.   IF IntuitionBase = 0 THEN
  184.     WriteString ("Open intuition failed"); WriteLn;
  185.   END;
  186.   
  187.   (* Initialize the New window structure *)
  188.   InitWindow (MyWindow);
  189.   (* Set up the requester gadget *)
  190.   SetUpGadget ();
  191.   (* Set up the requester *)
  192.   SetUpRequester ();
  193.   (* Now open the window *)
  194.   wp := OpenWindow (MyWindow);
  195.  
  196.   (* Display a requester *)
  197.   succ := Request (SimpleReq, wp^);
  198.   LOOP (* Until the window is closed *)
  199.     (* Wait for a message from intuition *)
  200.     msgptr := WaitPort (wp^.UserPort); 
  201.     (* After the message comes, get it and reply to it *)
  202.     msgptr := GetMsg (wp^.UserPort); 
  203.     class := msgptr^.Class;
  204.     (* Reply as soon as possible *)
  205.     ReplyMsg (msgptr);
  206.     (* Print a trace message showing what we got *)
  207.     IF class = IDCMPFlagsSet{CloseWindow} THEN
  208.       WriteString ("Close window");
  209.       EXIT
  210.     ELSIF class = IDCMPFlagsSet{ReqClear} THEN
  211.       WriteString ("Req clear msg");
  212.     ELSIF class = IDCMPFlagsSet{GadgetDown} THEN
  213.       WriteString ("Gadget  down");
  214.     ELSIF class = IDCMPFlagsSet{GadgetUp} THEN
  215.       WriteString ("Gadget  up");
  216.     END; (* IF *)
  217.     WriteLn;
  218.   END; (* LOOP *)
  219.  
  220.   Windows.CloseWindow (wp^);
  221. END SimpleReq.
  222.